Grabbing SPINS gradients
## -- Attaching packages --------------------------------------- tidyverse 1.3.1 --
## v ggplot2 3.3.5 v purrr 0.3.4
## v tibble 3.1.6 v dplyr 1.0.7
## v tidyr 1.1.4 v stringr 1.4.0
## v readr 2.0.1 v forcats 0.5.1
## -- Conflicts ------------------------------------------ tidyverse_conflicts() --
## x dplyr::filter() masks stats::filter()
## x dplyr::lag() masks stats::lag()
## Warning: package 'ggseg' was built under R version 4.1.3
## Loading required package: prettyGraphs
## Loading required package: ExPosition
##
## Attaching package: 'plotly'
## The following object is masked from 'package:ggplot2':
##
## last_plot
## The following object is masked from 'package:stats':
##
## filter
## The following object is masked from 'package:graphics':
##
## layout
##
## Attaching package: 'colorspace'
## The following object is masked from 'package:PTCA4CATA':
##
## lighten
## New names:
## * `` -> ...1
## Rows: 337120 Columns: 16
## -- Column specification --------------------------------------------------------
## Delimiter: ","
## chr (5): ROI, Task, Subject, Network, Site
## dbl (11): ...1, grad1, grad2, grad3, grad4, grad5, grad6, grad7, grad8, grad...
##
## i Use `spec()` to retrieve the full column specification for this data.
## i Specify the column types or set `show_col_types = FALSE` to quiet this message.
## New names:
## * `` -> ...1
## Rows: 337120 Columns: 16
## -- Column specification --------------------------------------------------------
## Delimiter: ","
## chr (5): ROI, Task, Subject, Network, Site
## dbl (11): ...1, grad1, grad2, grad3, grad4, grad5, grad6, grad7, grad8, grad...
##
## i Use `spec()` to retrieve the full column specification for this data.
## i Specify the column types or set `show_col_types = FALSE` to quiet this message.
## Rows: 354 Columns: 38
## -- Column specification --------------------------------------------------------
## Delimiter: ","
## chr (7): record_id, site, scanner, diagnostic_group, demo_sex, subject, ses...
## dbl (22): demo_age_study_entry, scog_tasit1_total, scog_tasit2_total, scog_t...
## lgl (9): term_early_withdraw, has_RS_grads, has_EA_grads, RS_QC_exclude, EA...
##
## i Use `spec()` to retrieve the full column specification for this data.
## i Specify the column types or set `show_col_types = FALSE` to quiet this message.
## [1] "record_id" "site"
## [3] "scanner" "diagnostic_group"
## [5] "demo_sex" "demo_age_study_entry"
## [7] "term_early_withdraw" "scog_tasit1_total"
## [9] "scog_tasit2_total" "scog_tasit3_total"
## [11] "np_composite_tscore" "np_domain_tscore_process_speed"
## [13] "np_domain_tscore_att_vigilance" "np_domain_tscore_work_mem"
## [15] "np_domain_tscore_verbal_learning" "np_domain_tscore_visual_learning"
## [17] "np_domain_tscore_reasoning_ps" "np_domain_tscore_social_cog"
## [19] "bprs_factor_pos_symp" "bprs_factor_total"
## [21] "bprs_factor_neg_symp" "qls_total"
## [23] "sans_total_sc" "bsfs_total"
## [25] "subject" "session"
## [27] "n_scans_task-emp" "n_scans_task-rest"
## [29] "fd_mean_task-emp" "fd_mean_task-rest"
## [31] "has_RS_grads" "has_EA_grads"
## [33] "RS_QC_exclude" "EA_QC_exclude"
## [35] "RS_mo_exclude" "EA_mo_exclude"
## [37] "withdrawn_exclude" "exclude_MRI"
## [1] "scog_tasit1_total" "scog_tasit2_total"
## [3] "scog_tasit3_total" "np_composite_tscore"
## [5] "np_domain_tscore_process_speed" "np_domain_tscore_att_vigilance"
## [7] "np_domain_tscore_work_mem" "np_domain_tscore_verbal_learning"
## [9] "np_domain_tscore_visual_learning" "np_domain_tscore_reasoning_ps"
## [11] "np_domain_tscore_social_cog" "bprs_factor_pos_symp"
## [13] "bprs_factor_total" "bprs_factor_neg_symp"
## [15] "qls_total" "sans_total_sc"
## [17] "bsfs_total"
grad.sub <- spins_grads_wide$Subject[order(spins_grads_wide$Subject)]
behav.sub <- lol_spins_behav$subject[order(lol_spins_behav$subject)]
behav.sub[behav.sub %in% grad.sub == FALSE]
## [1] "sub-CMP0180" "sub-CMP0182" "sub-CMP0196" "sub-CMP0198" "sub-CMP0213"
## [6] "sub-ZHH0034"
grad.sub[grad.sub %in% behav.sub == FALSE]
## [1] "sub-CMH0009" "sub-CMH0036" "sub-CMH0046" "sub-CMH0047" "sub-CMH0048"
## [6] "sub-CMH0050" "sub-CMH0052" "sub-CMH0059" "sub-CMH0070" "sub-CMH0072"
## [11] "sub-CMH0097" "sub-CMH0104" "sub-CMH0114" "sub-CMH0118" "sub-CMH0126"
## [16] "sub-CMH0136" "sub-CMH0155" "sub-CMH0176" "sub-CMH0197" "sub-CMP0175"
## [21] "sub-CMP0178" "sub-CMP0183" "sub-CMP0202" "sub-MRC0001" "sub-MRC0008"
## [26] "sub-MRC0010" "sub-MRC0012" "sub-MRC0013" "sub-MRC0023" "sub-MRC0042"
## [31] "sub-MRC0044" "sub-MRC0046" "sub-MRC0047" "sub-MRC0051" "sub-MRC0058"
## [36] "sub-MRC0060" "sub-MRC0070" "sub-MRC0071" "sub-MRP0019" "sub-MRP0067"
## [41] "sub-MRP0079" "sub-MRP0093" "sub-MRP0099" "sub-MRP0105" "sub-MRP0116"
## [46] "sub-MRP0121" "sub-MRP0132" "sub-MRP0143" "sub-MRP0165" "sub-ZHH0014"
## [51] "sub-ZHH0017" "sub-ZHH0019" "sub-ZHH0020" "sub-ZHH0022" "sub-ZHH0023"
## [56] "sub-ZHH0033" "sub-ZHH0037" "sub-ZHH0040" "sub-ZHH0044" "sub-ZHH0045"
## [61] "sub-ZHH0047" "sub-ZHH0048" "sub-ZHH0052" "sub-ZHH0053" "sub-ZHH0054"
## [66] "sub-ZHH0057" "sub-ZHP0063" "sub-ZHP0065" "sub-ZHP0085" "sub-ZHP0093"
## [71] "sub-ZHP0094" "sub-ZHP0095" "sub-ZHP0097" "sub-ZHP0098" "sub-ZHP0100"
## [76] "sub-ZHP0103" "sub-ZHP0105" "sub-ZHP0119" "sub-ZHP0129" "sub-ZHP0133"
## [81] "sub-ZHP0134" "sub-ZHP0141" "sub-ZHP0142" "sub-ZHP0143" "sub-ZHP0144"
## [86] "sub-ZHP0155" "sub-ZHP0162" "sub-ZHP0168"
## kept subjects
kept.sub <- behav.sub[behav.sub %in% grad.sub] # 342
kept.sub[complete.cases(spins_behav_num[kept.sub,c(1:11, 17)]) == FALSE]
## [1] "sub-CMH0013" "sub-ZHP0081" "sub-ZHP0083" "sub-ZHP0118"
kept.sub <- kept.sub[complete.cases(spins_behav_num[kept.sub,c(1:11, 17)])] # 338
## grab the matching data
behav.dat <- spins_behav_num[kept.sub,c(1:11, 17)]
spins_grads_wide_org <- spins_grads_wide[,-1]
rownames(spins_grads_wide_org) <- spins_grads_wide$Subject
grad.dat <- spins_grads_wide_org[kept.sub,]
## variables to regress out
regout.dat <- var2regout_num[kept.sub,]
rm(spins_grads_wide, spins_grads_wide_org, lol_spins_behav, spins_behav_num, spins_grads_num)
behav.reg <- apply(behav.dat, 2, function(x) lm(x~regout.dat$demo_sex + regout.dat$demo_age_study_entry + regout.dat$fd_mean_task.rest)$residual)
grad.reg <- apply(grad.dat, 2, function(x) lm(x~regout.dat$demo_sex + regout.dat$demo_age_study_entry + regout.dat$fd_mean_task.rest)$residual)
networks <- read_delim("../networks.txt",
"\t", escape_double = FALSE, trim_ws = TRUE) %>%
select(NETWORK, NETWORKKEY, RED, GREEN, BLUE, ALPHA) %>%
distinct() %>%
add_row(NETWORK = "Subcortical", NETWORKKEY = 13, RED = 0, GREEN=0, BLUE=0, ALPHA=255) %>%
mutate(hex = rgb(RED, GREEN, BLUE, maxColorValue = 255)) %>%
arrange(NETWORKKEY)
## Rows: 718 Columns: 12
## -- Column specification --------------------------------------------------------
## Delimiter: "\t"
## chr (4): LABEL, HEMISPHERE, NETWORK, GLASSERLABELNAME
## dbl (8): INDEX, KEYVALUE, RED, GREEN, BLUE, ALPHA, NETWORKKEY, NETWORKSORTED...
##
## i Use `spec()` to retrieve the full column specification for this data.
## i Specify the column types or set `show_col_types = FALSE` to quiet this message.
networks$hex <- darken(networks$hex, 0.2)
# oi <- networks$hex
# swatchplot(
# "-40%" = lighten(oi, 0.4),
# "-20%" = lighten(oi, 0.2),
# " 0%" = oi,
# " 20%" = darken(oi, 0.2),
# " 25%" = darken(oi, 0.25),
# " 30%" = darken(oi, 0.3),
# " 35%" = darken(oi, 0.35),
# off = c(0, 0)
# )
networks
## # A tibble: 13 x 7
## NETWORK NETWORKKEY RED GREEN BLUE ALPHA hex
## <chr> <dbl> <dbl> <dbl> <dbl> <dbl> <chr>
## 1 Visual1 1 0 0 255 255 #0707CF
## 2 Visual2 2 100 0 255 255 #5001D0
## 3 Somatomotor 3 0 255 255 255 #11C7C7
## 4 Cingulo-Opercular 4 153 0 153 255 #7D007D
## 5 Dorsal-Attention 5 0 255 0 255 #10C710
## 6 Language 6 0 155 155 255 #097A7A
## 7 Frontoparietal 7 255 255 0 255 #C7C70B
## 8 Auditory 8 250 62 251 255 #D105D2
## 9 Default 9 255 0 0 255 #CC0303
## 10 Posterior-Multimodal 10 177 89 40 255 #88492D
## 11 Ventral-Multimodal 11 255 157 0 255 #C97B05
## 12 Orbito-Affective 12 65 125 0 168 #336400
## 13 Subcortical 13 0 0 0 255 #000000
## match ROIs to networks
ROI.network.match <- cbind(spins_grads$ROI, spins_grads$Network) %>% unique
ROI.idx <- ROI.network.match[,2]
names(ROI.idx) <- ROI.network.match[,1]
### match networks with colors
net.col.idx <- networks$hex
names(net.col.idx) <- networks$NETWORK
## design matrix for subjects
sub.dx <- spins_dx_org[kept.sub,]
diagnostic.col <- sub.dx$diagnostic_group %>% as.matrix %>% makeNominalData() %>% createColorVectorsByDesign()
rownames(diagnostic.col$gc) <- sub(".","", rownames(diagnostic.col$gc))
## design matrix for columns - behavioral
behav.dx <- matrix(nrow = ncol(behav.dat), ncol = 1, dimnames = list(colnames(behav.dat), "type")) %>% as.data.frame
behav.col <- c("scog" = "#F28E2B",
"np" = "#59A14F",
"bsfs" = "#D37295")
behav.dx$type <- sub("(^[^_]+).*", "\\1", colnames(behav.dat))
behav.dx$type.col <- recode(behav.dx$type, !!!behav.col)
## design matrix for columns - gradient
grad.dx <- matrix(nrow = ncol(grad.dat), ncol = 4, dimnames = list(colnames(grad.dat), c("gradient", "ROI", "network", "network.col"))) %>% as.data.frame
grad.dx$gradient <- sub("(^[^.]+).*", "\\1", colnames(grad.dat))
grad.dx$ROI <- sub("^[^.]+.(*)", "\\1", colnames(grad.dat))
grad.dx$network <- recode(grad.dx$ROI, !!!ROI.idx)
grad.dx$network.col <- recode(grad.dx$network, !!!net.col.idx)
## get different alpha for gradients
grad.col.idx <- c("grad1" = "grey30",
"grad2" = "grey60",
"grad3" = "grey90")
grad.dx$gradient.col <- recode(grad.dx$gradient, !!!grad.col.idx)
## for heatmap
col.heat <- colorRampPalette(c("red", "white", "blue"))(256)
pls.res <- tepPLS(behav.reg, grad.reg, DESIGN = sub.dx$diagnostic_group, make_design_nominal = TRUE, graphs = FALSE)
pls.boot <- data4PCCAR::Boot4PLSC(behav.reg, grad.reg, scale1 = TRUE, scale2 = TRUE)
## Registered S3 method overwritten by 'data4PCCAR':
## method from
## print.str_colorsOfMusic PTCA4CATA
## swith direction for dimension 3
# pls.res$TExPosition.Data$fi[,3] <- pls.res$TExPosition.Data$fi[,3]*-1
# pls.res$TExPosition.Data$fj[,3] <- pls.res$TExPosition.Data$fj[,3]*-1
# pls.res$TExPosition.Data$pdq$p[,3] <- pls.res$TExPosition.Data$pdq$p[,3]*-1
# pls.res$TExPosition.Data$pdq$q[,3] <- pls.res$TExPosition.Data$pdq$q[,3]*-1
# pls.res$TExPosition.Data$lx[,3] <- pls.res$TExPosition.Data$lx[,3]*-1
# pls.res$TExPosition.Data$ly[,3] <- pls.res$TExPosition.Data$ly[,3]*-1
## Scree plot
PlotScree(pls.res$TExPosition.Data$eigs)
## Print singular values
pls.res$TExPosition.Data$pdq$Dv
## [1] 7.2287937 2.6214751 2.1318204 1.7321390 1.6593210 1.4797230 1.3543237
## [8] 1.1349337 1.0842758 1.0043084 0.7565438 0.2203512
## Print eigenvalues
pls.res$TExPosition.Data$eigs
## [1] 52.25545860 6.87213167 4.54465816 3.00030556 2.75334627 2.18958013
## [7] 1.83419265 1.28807453 1.17565393 1.00863546 0.57235857 0.04855467
## Compare the inertia to the largest possible inertia
sum(cor(behav.dat, grad.dat)^2)
## [1] 92.40188
sum(cor(behav.dat, grad.dat)^2)/(ncol(behav.dat)*ncol(grad.dat))
## [1] 0.006547752
Here, we show that the effect that PLSC decomposes is pretty small to begin with. The effect size of the correlation between the two tables is 92.40 which accounts for 0.0065 of the largest possible effect.
lxly.out[[1]]
gridExtra::grid.arrange(bar.grad1, bar.grad2, bar.grad3, ncol = 1)
PrettyBarPlot2(pls.res$TExPosition.Data$fi[,1],
threshold = 0,
color4bar = ifelse(pls.boot$bootRatiosSignificant.i[,1] == TRUE, behav.dx$type.col, "grey90"),
horizontal = FALSE, main = "Scores - behavioural")
## Warning: Vectorized input to `element_text()` is not officially supported.
## Results may be unexpected or may change in future versions of ggplot2.
cor.heat <- pls.res$TExPosition.Data$X %>% heatmap(col = col.heat)
## control
grad.dat.ctrl <- grad.dat[sub.dx$diagnostic_group == "control",]
behav.dat.ctrl <- behav.dat[sub.dx$diagnostic_group == "control",]
corX.ctrl <- cor(as.matrix(behav.dat.ctrl),as.matrix(grad.dat.ctrl))
heatmap(corX.ctrl[cor.heat$rowInd, cor.heat$colInd], col = col.heat, Rowv = NA, Colv = NA)
## case
grad.dat.case <- grad.dat[sub.dx$diagnostic_group == "case",]
behav.dat.case <- behav.dat[sub.dx$diagnostic_group == "case",]
corX.case <- cor(as.matrix(behav.dat.case),as.matrix(grad.dat.case))
heatmap(corX.case[cor.heat$rowInd, cor.heat$colInd], col = col.heat, Rowv = NA, Colv = NA)
lxly.out[[2]]
gridExtra::grid.arrange(bar.grad1, bar.grad2, bar.grad3, ncol = 1)
PrettyBarPlot2(pls.res$TExPosition.Data$fi[,2],
threshold = 0, color4bar = ifelse(pls.boot$bootRatiosSignificant.i[,2] == TRUE, behav.dx$type.col, "grey90"),
horizontal = FALSE, main = "Scores - behavioural")
dim1.est <- pls.res$TExPosition.Data$pdq$Dv[1]*as.matrix(pls.res$TExPosition.Data$pdq$p[,1], ncol = 1) %*% t(as.matrix(pls.res$TExPosition.Data$pdq$q[,1], ncol = 1))
cor.heat.res1 <- (pls.res$TExPosition.Data$X - dim1.est) %>% heatmap(col = col.heat)
## control
res1.ctrl <- corX.ctrl - dim1.est
heatmap(res1.ctrl[cor.heat.res1$rowInd, cor.heat.res1$colInd], col = col.heat, Rowv = NA, Colv = NA)
## case
res1.case <- corX.case - dim1.est
heatmap(res1.case[cor.heat.res1$rowInd, cor.heat.res1$colInd], col = col.heat, Rowv = NA, Colv = NA)
lxly.out[[3]]
gridExtra::grid.arrange(bar.grad1, bar.grad2, bar.grad3, ncol = 1)
PrettyBarPlot2(pls.res$TExPosition.Data$fi[,3],
threshold = 0, color4bar = ifelse(pls.boot$bootRatiosSignificant.i[,3] == TRUE, behav.dx$type.col, "grey90"),
horizontal = FALSE, main = "Scores - behavioural")
dim2.est <- (as.matrix(pls.res$TExPosition.Data$pdq$p[,1:2]) %*% pls.res$TExPosition.Data$pdq$Dd[1:2,1:2] %*% t(as.matrix(pls.res$TExPosition.Data$pdq$q[,1:2])))
cor.heat.res2 <- heatmap(pls.res$TExPosition.Data$X - dim2.est, col = col.heat)
## control
res2.ctrl <- corX.ctrl - dim1.est - dim2.est
heatmap(res2.ctrl[cor.heat.res2$rowInd, cor.heat.res2$colInd], col = col.heat, Rowv = NA, Colv = NA)
## case
res2.case <- corX.case - dim1.est - dim2.est
heatmap(res2.case[cor.heat.res2$rowInd, cor.heat.res2$colInd], col = col.heat, Rowv = NA, Colv = NA)
## merging atlas and data by 'label'
## merging atlas and data by 'label'
## merging atlas and data by 'label'
## merging atlas and data by 'label'
## merging atlas and data by 'label'
## merging atlas and data by 'label'
3D plot of the gradients
We need to interpret the arrows with cautious, because only the direction and the magnitude are meaningful but not the end point.
We need to interpret the arrows with cautious, because only the direction and the magnitude are meaningful but not the end point.
We need to interpret the arrows with cautious, because only the direction and the magnitude are meaningful but not the end point.